home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / pcl_src.zoo / defcombin.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1992-08-21  |  16.1 KB  |  452 lines
  1. ;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27.  
  28. (in-package 'pcl)
  29.  
  30. ;;;
  31. ;;; DEFINE-METHOD-COMBINATION
  32. ;;;
  33.  
  34. (defmacro define-method-combination (&whole form &rest args)
  35.   (declare (ignore args))
  36.   (if (and (cddr form)
  37.        (listp (caddr form)))
  38.       (expand-long-defcombin form)
  39.       (expand-short-defcombin form)))
  40.  
  41.  
  42. ;;;
  43. ;;; STANDARD method combination
  44. ;;;
  45. ;;; The STANDARD method combination type is implemented directly by the class
  46. ;;; STANDARD-METHOD-COMBINATION.  The method on COMPUTE-EFFECTIVE-METHOD does
  47. ;;; standard method combination directly and is defined by hand in the file
  48. ;;; combin.lisp.  The method for FIND-METHOD-COMBINATION must appear in this
  49. ;;; file for bootstrapping reasons.
  50. ;;;
  51. ;;; A commented out copy of this definition appears in combin.lisp.
  52. ;;; If you change this definition here, be sure to change it there
  53. ;;; also.
  54. ;;;
  55. (defmethod find-method-combination ((generic-function generic-function)
  56.                     (type (eql 'standard))
  57.                     options)
  58.   (when options
  59.     (method-combination-error
  60.       "The method combination type STANDARD accepts no options."))
  61.   *standard-method-combination*)
  62.  
  63.  
  64.  
  65. ;;;
  66. ;;; short method combinations
  67. ;;;
  68. ;;; Short method combinations all follow the same rule for computing the
  69. ;;; effective method.  So, we just implement that rule once.  Each short
  70. ;;; method combination object just reads the parameters out of the object
  71. ;;; and runs the same rule.
  72. ;;;
  73. ;;;
  74. (defclass short-method-combination (standard-method-combination)
  75.      ((operator
  76.     :reader short-combination-operator
  77.     :initarg :operator)
  78.       (identity-with-one-argument
  79.     :reader short-combination-identity-with-one-argument
  80.     :initarg :identity-with-one-argument))
  81.   (:predicate-name short-method-combination-p))
  82.  
  83. (defun expand-short-defcombin (whole)
  84.   (let* ((type (cadr whole))
  85.      (documentation
  86.        (getf (cddr whole) :documentation ""))
  87.      (identity-with-one-arg
  88.        (getf (cddr whole) :identity-with-one-argument nil))
  89.      (operator 
  90.        (getf (cddr whole) :operator type)))
  91.     (make-top-level-form `(define-method-combination ,type)
  92.              '(load eval)
  93.       `(load-short-defcombin
  94.      ',type ',operator ',identity-with-one-arg ',documentation))))
  95.  
  96. (defun load-short-defcombin (type operator ioa doc)
  97.   (let* ((truename (load-truename))
  98.      (specializers
  99.        (list (find-class 'generic-function)
  100.          (intern-eql-specializer type)
  101.          *the-class-t*))
  102.      (old-method
  103.        (get-method #'find-method-combination () specializers nil))
  104.      (new-method nil))
  105.     (setq new-method
  106.       (make-instance 'standard-method
  107.         :qualifiers ()
  108.         :specializers specializers
  109.         :lambda-list '(generic-function type options)
  110.             :function
  111.                 #'(lambda (args next-methods)
  112.                     (declare (ignore next-methods))
  113.                     (apply #'(lambda (gf type options)
  114.                        (declare (ignore gf))
  115.                          (do-short-method-combination
  116.                            type options operator ioa new-method doc))
  117.                            args))
  118.         :optimized-function
  119.                 #'(lambda (gf type options)
  120.             (declare (ignore gf))
  121.               (do-short-method-combination
  122.                 type options operator ioa new-method doc))
  123.         :definition-source `((define-method-combination ,type) ,truename)))
  124.     (when old-method
  125.       (remove-method #'find-method-combination old-method))
  126.     (add-method #'find-method-combination new-method)))
  127.  
  128. (defun do-short-method-combination (type options operator ioa method doc)
  129.   (cond ((null options) (setq options '(:most-specific-first)))
  130.     ((equal options '(:most-specific-first)))
  131.     ((equal options '(:most-specific-last)))
  132.     (t
  133.      (method-combination-error
  134.        "Illegal options to a short method combination type.~%~
  135.             The method combination type ~S accepts one option which~%~
  136.             must be either :MOST-SPECIFIC-FIRST or :MOST-SPECIFIC-LAST."
  137.        type)))
  138.   (make-instance 'short-method-combination
  139.          :type type
  140.          :options options
  141.          :operator operator
  142.          :identity-with-one-argument ioa
  143.          :definition-source method
  144.          :documentation doc))
  145.  
  146. (defmethod compute-effective-method ((generic-function generic-function)
  147.                      (combin short-method-combination)
  148.                      applicable-methods)
  149.   (let ((type (method-combination-type combin))
  150.     (operator (short-combination-operator combin))
  151.     (ioa (short-combination-identity-with-one-argument combin))
  152.     (around ())
  153.     (primary ()))
  154.     (dolist (m applicable-methods)
  155.       (let ((qualifiers (method-qualifiers m)))
  156.     (flet ((lose (method why)
  157.          (invalid-method-error
  158.            method
  159.            "The method ~S ~A.~%~
  160.                     The method combination type ~S was defined with the~%~
  161.                     short form of DEFINE-METHOD-COMBINATION and so requires~%~
  162.                     all methods have either the single qualifier ~S or the~%~
  163.                     single qualifier :AROUND."
  164.            method why type type)))
  165.       (cond ((null qualifiers)
  166.          (lose m "has no qualifiers"))
  167.         ((cdr qualifiers)
  168.          (lose m "has more than one qualifier"))
  169.         ((eq (car qualifiers) :around)
  170.          (push m around))
  171.         ((eq (car qualifiers) type)
  172.          (push m primary))
  173.         (t
  174.          (lose m "has an illegal qualifier"))))))
  175.     (setq around (nreverse around))
  176.     (unless (memq :most-specific-last (method-combination-options combin))
  177.       (setq primary (nreverse primary)))
  178.     (let ((main-method
  179.         (if (and (null (cdr primary))
  180.              (not (null ioa)))
  181.         `(call-method ,(car primary) ())
  182.         `(,operator ,@(mapcar #'(lambda (m) `(call-method ,m ()))
  183.                       primary)))))
  184.       (cond ((null primary)
  185.          `(error "No ~S methods for the generic function ~S."
  186.              ',type ',generic-function))
  187.         ((null around) main-method)
  188.         (t
  189.          `(call-method ,(car around)
  190.                (,@(cdr around) (make-method ,main-method))))))))
  191.  
  192.  
  193. ;;;
  194. ;;; long method combinations
  195. ;;;
  196. ;;;
  197.  
  198. (defclass long-method-combination (standard-method-combination)
  199.      ((function :initarg :function
  200.         :reader long-method-combination-function)))
  201.  
  202. (defun expand-long-defcombin (form)
  203.   (let ((type (cadr form))
  204.     (lambda-list (caddr form))
  205.     (method-group-specifiers (cadddr form))
  206.     (body (cddddr form))
  207.     (arguments-option ())
  208.     (gf-var nil))
  209.     (when (and (consp (car body)) (eq (caar body) :arguments))
  210.       (setq arguments-option (cdr (pop body))))
  211.     (when (and (consp (car body)) (eq (caar body) :generic-function))
  212.       (setq gf-var (cadr (pop body))))
  213.     (multiple-value-bind (documentation function)
  214.     (make-long-method-combination-function
  215.       type lambda-list method-group-specifiers arguments-option gf-var
  216.       body)
  217.       (make-top-level-form `(define-method-combination ,type)
  218.                '(load eval)
  219.     `(load-long-defcombin ',type ',documentation #',function)))))
  220.  
  221. (defvar *long-method-combination-functions* (make-hash-table :test #'eq))
  222.  
  223. (defun load-long-defcombin (type doc function)
  224.   (let* ((specializers
  225.        (list (find-class 'generic-function)
  226.          (intern-eql-specializer type)
  227.          *the-class-t*))
  228.      (old-method
  229.        (get-method #'find-method-combination () specializers nil))
  230.      (new-method
  231.        (make-instance 'standard-method
  232.          :qualifiers ()
  233.          :specializers specializers
  234.          :lambda-list '(generic-function type options)
  235.          :function
  236.                #'(lambda (args next-methods)
  237.                    (declare (ignore next-methods))
  238.                    (apply  #'(lambda (generic-function type options)
  239.                        (declare (ignore generic-function))
  240.                        (make-instance 'long-method-combination
  241.                          :type type
  242.                          :documentation doc
  243.                          :options options))
  244.                            args))
  245.          :optimized-function
  246.                #'(lambda (generic-function type options)
  247.            (declare (ignore generic-function))
  248.            (make-instance 'long-method-combination
  249.              :type type
  250.              :documentation doc
  251.              :options options))
  252.          :definition-source `((define-method-combination ,type)
  253.                   ,(load-truename)))))
  254.     (setf (gethash type *long-method-combination-functions*) function)
  255.     (when old-method (remove-method #'find-method-combination old-method))
  256.     (add-method #'find-method-combination new-method)))
  257.  
  258. (defmethod compute-effective-method ((generic-function generic-function)
  259.                      (combin long-method-combination)
  260.                      applicable-methods)
  261.   (method-function-funcall (gethash (method-combination-type combin)
  262.                             *long-method-combination-functions*)
  263.                        generic-function
  264.                        combin
  265.                        applicable-methods))
  266.  
  267. ;;;
  268. ;;;
  269. ;;;
  270. (defun make-long-method-combination-function
  271.        (type ll method-group-specifiers arguments-option gf-var body)
  272.   (declare (values documentation function))
  273.   (declare (ignore type))
  274.   (multiple-value-bind (documentation declarations real-body)
  275.       (extract-declarations body)
  276.  
  277.     (let ((wrapped-body
  278.         (wrap-method-group-specifier-bindings method-group-specifiers
  279.                           declarations
  280.                           real-body)))
  281.       (when gf-var
  282.     (push `(,gf-var .generic-function.) (cadr wrapped-body)))
  283.       
  284.       (when arguments-option
  285.     (setq wrapped-body (deal-with-arguments-option wrapped-body
  286.                                arguments-option)))
  287.  
  288.       (when ll
  289.     (setq wrapped-body
  290.           `(apply #'(lambda ,ll ,wrapped-body)
  291.               (method-combination-options .method-combination.))))
  292.  
  293.       (values
  294.     documentation
  295.     `(lambda (.generic-function. .method-combination. .applicable-methods.)
  296.        (progn .generic-function. .method-combination. .applicable-methods.)
  297.        (block .long-method-combination-function. ,wrapped-body))))))
  298. ;;
  299. ;; parse-method-group-specifiers parse the method-group-specifiers
  300. ;;
  301.  
  302. (defun wrap-method-group-specifier-bindings
  303.        (method-group-specifiers declarations real-body)
  304.   (with-gathering ((names (collecting))
  305.            (specializer-caches (collecting))
  306.            (cond-clauses (collecting))
  307.            (required-checks (collecting))
  308.            (order-cleanups (collecting)))
  309.       (dolist (method-group-specifier method-group-specifiers)
  310.     (multiple-value-bind (name tests description order required)
  311.         (parse-method-group-specifier method-group-specifier)
  312.       (declare (ignore description))
  313.       (let ((specializer-cache (gensym)))
  314.         (gather name names)
  315.         (gather specializer-cache specializer-caches)
  316.         (gather `((or ,@tests)
  317.               (if  (equal ,specializer-cache .specializers.)
  318.                (return-from .long-method-combination-function.
  319.                  '(error "More than one method of type ~S ~
  320.                                       with the same specializers."
  321.                      ',name))
  322.                (setq ,specializer-cache .specializers.))
  323.               (push .method. ,name))
  324.             cond-clauses)
  325.         (when required
  326.           (gather `(when (null ,name)
  327.              (return-from .long-method-combination-function.
  328.                '(error "No ~S methods." ',name)))
  329.               required-checks))
  330.         (loop (unless (and (constantp order)
  331.                    (neq order (setq order (eval order))))
  332.             (return t)))
  333.         (gather (cond ((eq order :most-specific-first)
  334.                `(setq ,name (nreverse ,name)))
  335.               ((eq order :most-specific-last) ())
  336.               (t
  337.                `(ecase ,order
  338.                   (:most-specific-first
  339.                 (setq ,name (nreverse ,name)))
  340.                   (:most-specific-last))))
  341.             order-cleanups))))
  342.    `(let (,@names ,@specializer-caches)
  343.       ,@declarations
  344.       (dolist (.method. .applicable-methods.)
  345.     (let ((.qualifiers. (method-qualifiers .method.))
  346.           (.specializers. (method-specializers .method.)))
  347.       (progn .qualifiers. .specializers.)
  348.       (cond ,@cond-clauses)))
  349.       ,@required-checks
  350.       ,@order-cleanups
  351.       ,@real-body)))
  352.    
  353. (defun parse-method-group-specifier (method-group-specifier)
  354.   (declare (values name tests description order required))
  355.   (let* ((name (pop method-group-specifier))
  356.      (patterns ())
  357.      (tests 
  358.        (gathering1 (collecting)
  359.          (block collect-tests
  360.            (loop
  361.          (if (or (null method-group-specifier)
  362.              (memq (car method-group-specifier)
  363.                    '(:description :order :required)))
  364.              (return-from collect-tests t)
  365.              (let ((pattern (pop method-group-specifier)))
  366.                (push pattern patterns)
  367.                (gather1 (parse-qualifier-pattern name pattern)))))))))
  368.     (values name
  369.         tests
  370.         (getf method-group-specifier :description
  371.           (make-default-method-group-description patterns))
  372.         (getf method-group-specifier :order :most-specific-first)
  373.         (getf method-group-specifier :required nil))))
  374.  
  375. (defun parse-qualifier-pattern (name pattern)
  376.   (cond ((eq pattern '()) `(null .qualifiers.))
  377.     ((eq pattern '*) 't)
  378.     ((symbolp pattern) `(,pattern .qualifiers.))
  379.     ((listp pattern) `(qualifier-check-runtime ',pattern .qualifiers.))
  380.     (t (error "In the method group specifier ~S,~%~
  381.                    ~S isn't a valid qualifier pattern."
  382.           name pattern))))
  383.  
  384. (defun qualifier-check-runtime (pattern qualifiers)
  385.   (loop (cond ((and (null pattern) (null qualifiers))
  386.            (return t))
  387.           ((eq pattern '*) (return t))
  388.           ((and pattern qualifiers (eq (car pattern) (car qualifiers)))
  389.            (pop pattern)
  390.            (pop qualifiers))          
  391.           (t (return nil)))))
  392.  
  393. (defun make-default-method-group-description (patterns)
  394.   (if (cdr patterns)
  395.       (format nil
  396.           "methods matching one of the patterns: ~{~S, ~} ~S"
  397.           (butlast patterns) (car (last patterns)))
  398.       (format nil
  399.           "methods matching the pattern: ~S"
  400.           (car patterns))))
  401.  
  402.  
  403.  
  404. ;;;
  405. ;;; This baby is a complete mess.  I can't believe we put it in this
  406. ;;; way.  No doubt this is a large part of what drives MLY crazy.
  407. ;;;
  408. ;;; At runtime (when the effective-method is run), we bind an intercept
  409. ;;; lambda-list to the arguments to the generic function.
  410. ;;; 
  411. ;;; At compute-effective-method time, the symbols in the :arguments
  412. ;;; option are bound to the symbols in the intercept lambda list.
  413. ;;;
  414. (defun deal-with-arguments-option (wrapped-body arguments-option)
  415.   (let* ((intercept-lambda-list
  416.        (gathering1 (collecting)
  417.          (dolist (arg arguments-option)
  418.            (if (memq arg lambda-list-keywords)
  419.            (gather1 arg)
  420.            (gather1 (gensym))))))
  421.      (intercept-rebindings
  422.        (gathering1 (collecting)
  423.          (iterate ((arg (list-elements arguments-option))
  424.                (int (list-elements intercept-lambda-list)))
  425.            (unless (memq arg lambda-list-keywords)
  426.          (gather1 `(,arg ',int)))))))
  427.     ;;
  428.     ;;
  429.     (setf (cadr wrapped-body)
  430.       (append intercept-rebindings (cadr wrapped-body)))
  431.     ;;
  432.     ;; Be sure to fill out the intercept lambda list so that it can
  433.     ;; be too short if it wants to.
  434.     ;; 
  435.     (cond ((memq '&rest intercept-lambda-list))
  436.       ((memq '&allow-other-keys intercept-lambda-list))
  437.       ((memq '&key intercept-lambda-list)
  438.        (setq intercept-lambda-list
  439.          (append intercept-lambda-list '(&allow-other-keys))))
  440.       (t
  441.        (setq intercept-lambda-list
  442.          (append intercept-lambda-list '(&rest .ignore.)))))
  443.  
  444.     `(let ((inner-result. ,wrapped-body))
  445.        `(apply #'(lambda ,',intercept-lambda-list
  446.            ,,(when (memq '.ignore. intercept-lambda-list)
  447.                ''(declare (ignore .ignore.)))
  448.            ,inner-result.)
  449.            .combined-method-args.))))
  450.  
  451.  
  452.